home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / FROMUTS / XLISP1 / lisp / TURTLE < prev   
Lisp/Scheme  |  1990-02-24  |  4KB  |  151 lines
  1. ; This is a sample XLISP program
  2. ; It implements a simple form of programmable turtle for the Archimedes.
  3.  
  4. ; To run it:
  5.  
  6. ;       A>xlisp pt
  7.  
  8. ; This should cause the screen to be cleared and two turtles to appear.
  9. ; They should each execute their simple programs and then the prompt
  10. ; should return.  Look at the code to see how all of this works.
  11.  
  12. ; Get some more memory
  13. (expand 1)
  14.  
  15. ; Move the cursor to the currently set bottom position and clear the line
  16. ;  under it
  17. (defun bottom ()
  18.     (set-cursor by bx)
  19.     (clear-eos))
  20.  
  21. ; Clear the screen and go to the bottom
  22. (defun cb ()
  23.     (clear)
  24.     (bottom))
  25.  
  26.  
  27. ; ::::::::::::
  28. ; :: Turtle ::
  29. ; ::::::::::::
  30.  
  31. ; Define "Turtle" class
  32. (setq Turtle (Class :new '(xpos ypos char)))
  33.  
  34. ; Answer ":isnew" by initing a position and char and displaying.
  35. (Turtle :answer :isnew '() '(
  36.     (setq xpos (setq newx (+ newx 1)))
  37.     (setq ypos 12)
  38.     (setq char "*")
  39.     (self :display)
  40.     self))
  41.  
  42. ; Message ":display" prints its char at its current position
  43. (Turtle :answer :display '() '(
  44.     (set-cursor ypos xpos)
  45.     (princ char)
  46.     (bottom)
  47.     self))
  48.  
  49. ; Message ":char" sets char to its arg and displays it
  50. (Turtle :answer :char '(c) '(
  51.     (setq char c)
  52.     (self :display)))
  53.  
  54. ; Message ":goto" goes to a new place after clearing old one
  55. (Turtle :answer :goto '(x y) '(
  56.     (set-cursor ypos xpos) (princ " ")
  57.     (setq xpos x)
  58.     (setq ypos y)
  59.     (self :display)))
  60.  
  61. ; Message ":up" moves up if not at top
  62. (Turtle :answer :up '() '(
  63.     (if (> ypos 1)
  64.         (self :goto xpos (- ypos 1))
  65.         (bottom))))
  66.  
  67. ; Message ":down" moves down if not at bottom
  68. (Turtle :answer :down '() '(
  69.     (if (< ypos by)
  70.         (self :goto xpos (+ ypos 1))
  71.         (bottom))))
  72.  
  73. ; Message ":right" moves right if not at right
  74. (Turtle :answer :right '() '(
  75.     (if (< xpos 80)
  76.         (self :goto (+ xpos 1) ypos)
  77.         (bottom))))
  78.  
  79. ; Message ":left" moves left if not at left
  80. (Turtle :answer :left '() '(
  81.     (if (> xpos 1)
  82.         (self :goto (- xpos 1) ypos)
  83.         (bottom))))
  84.  
  85.  
  86. ; :::::::::::::
  87. ; :: PTurtle ::
  88. ; :::::::::::::
  89.  
  90. ; Define "DPurtle" programable turtle class
  91. (setq PTurtle (Class :new '(prog pc) '() Turtle))
  92.  
  93. ; Message ":program" stores a program
  94. (PTurtle :answer :program '(p) '(
  95.     (setq prog p)
  96.     (setq pc prog)
  97.     self))
  98.  
  99. ; Message ":step" executes a single program step
  100. (PTurtle :answer :step '() '(
  101.     (if (null pc)
  102.         (setq pc prog))
  103.     (if pc
  104.         (progn (self (car pc))
  105.                (setq pc (cdr pc))))
  106.     self))
  107.  
  108. ; Message ":step#" steps each turtle program n times
  109. (PTurtle :answer :step# '(n) '(
  110.     (dotimes (x n) (self :step))
  111.     self))
  112.  
  113.  
  114. ; ::::::::::::::
  115. ; :: PTurtles ::
  116. ; ::::::::::::::
  117.  
  118. ; Define "PTurtles" class
  119. (setq PTurtles (Class :new '(turtles)))
  120.  
  121. ; Message ":make" makes a programable turtle and adds it to the collection
  122. (PTurtles :answer :make '(x y &aux newturtle) '(
  123.     (setq newturtle (PTurtle :new))
  124.     (newturtle :goto x y)
  125.     (setq turtles (cons newturtle turtles))
  126.     newturtle))
  127.  
  128. ; Message ":step" steps each turtle program once
  129. (PTurtles :answer :step '() '(
  130.     (mapcar '(lambda (turtle) (turtle :step)) turtles)
  131.     self))
  132.  
  133. ; Message ":step#" steps each turtle program n times
  134. (PTurtles :answer :step# '(n) '(
  135.     (dotimes (x n) (self :step))
  136.     self))
  137.  
  138.  
  139. ; Initialize things and start up
  140. (setq bx 1)
  141. (setq by 21)
  142. (setq newx 1)
  143.  
  144. ; Create some programmable turtles
  145. (cb)
  146. (setq turtles (PTurtles :new))
  147. (setq t1 (turtles :make 40 10))
  148. (setq t2 (turtles :make 41 10))
  149. (t1 :program '(:left :right :up :down))
  150. (t2 :program '(:right :left :down :up))
  151.